home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / cddbco2a / ccd.cls next >
Text File  |  1999-10-13  |  7KB  |  224 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "CCd"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = False
  10. Option Explicit
  11.  
  12. Private Type MCI_OPEN_PARMS
  13.    dwCallback As Long
  14.    wDeviceID As Long
  15.    lpstrDeviceType As String
  16.    lpstrElementName As String
  17.    lpstrAlias As String
  18. End Type
  19.  
  20. Private Type MCI_SET_PARMS
  21.    dwCallback As Long
  22.    dwTimeFormat As Long
  23.    dwAudio As Long
  24. End Type
  25.  
  26. Private Type MCI_STATUS_PARMS
  27.    dwCallback As Long
  28.    dwReturn As Long
  29.    dwItem As Long
  30.    dwTrack As Integer
  31. End Type
  32.  
  33. Private Declare Function mciSendCommand Lib "winmm.dll" Alias "mciSendCommandA" _
  34.    (ByVal wDeviceID As Long, ByVal uMessage As Long, ByVal dwParam1 As Long, ByRef dwParam2 As Any) As Long
  35.  
  36. Private Const MMSYSERR_NOERROR = 0
  37.  
  38. Private Const MCI_CLOSE = &H804
  39. Private Const MCI_FORMAT_MSF = 2
  40. Private Const MCI_OPEN = &H803
  41. Private Const MCI_OPEN_ELEMENT = &H200&
  42. Private Const MCI_OPEN_TYPE = &H2000&
  43. Private Const MCI_SET = &H80D
  44. Private Const MCI_SET_TIME_FORMAT = &H400&
  45.  
  46. Private Const MCI_STATUS_ITEM = &H100&
  47. Private Const MCI_STATUS_LENGTH = &H1&
  48. Private Const MCI_STATUS_NUMBER_OF_TRACKS = &H3&
  49. Private Const MCI_STATUS_POSITION = &H2&
  50. Private Const MCI_TRACK = &H10&
  51. Private Const MCI_STATUS = &H814
  52.  
  53. Private mciOpenParms As MCI_OPEN_PARMS
  54. Private mciSetParms As MCI_SET_PARMS
  55. Private mciStatusParms As MCI_STATUS_PARMS
  56.  
  57. Private Type TTrackInfo
  58.    Minutes As Long
  59.    Seconds As Long
  60.    Frames As Long
  61.    FrameOffset As Long           ' Starting location in frames (used by QueryString)
  62. End Type
  63.  
  64. Private m_Error As Long          ' Error code from API call
  65. Private m_CID As String          ' Computed disc id
  66. Private m_Drive As String        ' Drive letter
  67. Private m_DeviceID As Long       ' Device Id
  68. Private m_NTracks As Integer     ' Number of tracks in CD
  69. Private m_Length As Long         ' Length of CD in seconds
  70. Private m_Tracks() As TTrackInfo ' Track info for each and every track on the CD
  71.                                  ' Zero based. Last index used for storing lead-out
  72.                                  ' position information.
  73.  
  74. Private Sub Class_Initialize()
  75.    m_CID = "(unavailable)"
  76.    m_Drive = ""
  77.    m_Error = 0
  78.    m_DeviceID = -1
  79.    m_NTracks = 0
  80. End Sub
  81.  
  82. Public Property Get DiscID() As String
  83.    DiscID = m_CID
  84. End Property
  85.  
  86. Public Property Get ErrorCode() As Long
  87.    Error = m_Error
  88. End Property
  89.  
  90. Public Sub Init(sDrive As String)
  91.    Dim p1 As Integer
  92.    m_Error = MMSYSERR_NOERROR
  93.    m_Drive = sDrive
  94.    If OpenCD Then
  95.       Call LoadCDInfo
  96.       CloseCD
  97.    End If
  98.    
  99. End Sub
  100.  
  101. Private Sub Class_Terminate()
  102.    If m_DeviceID <> -1 Then
  103.       CloseCD
  104.    End If
  105. End Sub
  106.  
  107. Private Function OpenCD() As Boolean
  108.    Dim sCode As Long, wDeviceID As Long
  109.    OpenCD = False
  110.    mciOpenParms.lpstrDeviceType = "cdaudio"
  111.    mciOpenParms.lpstrElementName = m_Drive
  112.    sCode = mciSendCommand(0, MCI_OPEN, (MCI_OPEN_TYPE Or MCI_OPEN_ELEMENT), mciOpenParms)
  113.    If sCode <> MMSYSERR_NOERROR Then
  114.       m_Error = sCode
  115.       Exit Function
  116.    End If
  117.    m_DeviceID = mciOpenParms.wDeviceID
  118.    mciSetParms.dwTimeFormat = MCI_FORMAT_MSF
  119.    sCode = mciSendCommand(m_DeviceID, MCI_SET, MCI_SET_TIME_FORMAT, mciSetParms)
  120.    If sCode <> MMSYSERR_NOERROR Then
  121.       m_Error = sCode
  122.       sCode = mciSendCommand(m_DeviceID, MCI_CLOSE, 0, 0)  ' Dont forget to close it
  123.       Exit Function
  124.    End If
  125.    OpenCD = True
  126. End Function
  127.  
  128. Private Sub CloseCD()
  129.    m_Error = mciSendCommand(m_DeviceID, MCI_CLOSE, 0, 0)
  130.    m_DeviceID = -1
  131. End Sub
  132.  
  133. Private Function LoadCDInfo() As Boolean
  134.    Dim sCode As Long
  135.    Dim p1 As Long, dwPosM As Long, dwPosS As Long, dwPosF As Long
  136.    Dim dwLenM As Long, dwLenS As Long, dwLenF As Long, dwpos As Long
  137.    Dim sum As Long, p2 As Long
  138.    On Error Resume Next
  139.    LoadCDInfo = False
  140.    mciStatusParms.dwItem = MCI_STATUS_NUMBER_OF_TRACKS
  141.    sCode = mciSendCommand(m_DeviceID, MCI_STATUS, MCI_STATUS_ITEM, mciStatusParms)
  142.    If sCode <> MMSYSERR_NOERROR Then
  143.       m_Error = sCode
  144.       Exit Function
  145.    End If
  146.    m_NTracks = mciStatusParms.dwReturn
  147.    ReDim m_Tracks(m_NTracks + 1) As TTrackInfo
  148.    For p1 = 1 To m_NTracks
  149.       mciStatusParms.dwItem = MCI_STATUS_POSITION
  150.       mciStatusParms.dwTrack = p1
  151.       sCode = mciSendCommand(m_DeviceID, MCI_STATUS, MCI_STATUS_ITEM Or MCI_TRACK, mciStatusParms)
  152.       If sCode <> MMSYSERR_NOERROR Then
  153.          m_Error = sCode
  154.          Exit Function
  155.       End If
  156.       m_Tracks(p1 - 1).Frames = (mciStatusParms.dwReturn \ 65536) And &HFF
  157.       m_Tracks(p1 - 1).Seconds = (mciStatusParms.dwReturn \ 256) And &HFF
  158.       m_Tracks(p1 - 1).Minutes = (mciStatusParms.dwReturn) And &HFF
  159.       m_Tracks(p1 - 1).FrameOffset = (m_Tracks(p1 - 1).Minutes * 60 * 75) + _
  160.                                    (m_Tracks(p1 - 1).Seconds * 75) + _
  161.                                    (m_Tracks(p1 - 1).Frames)
  162.    Next p1
  163.    mciStatusParms.dwItem = MCI_STATUS_LENGTH
  164.    mciStatusParms.dwTrack = m_NTracks
  165.    sCode = mciSendCommand(m_DeviceID, MCI_STATUS, MCI_STATUS_ITEM Or MCI_TRACK, mciStatusParms)
  166.    If sCode <> MMSYSERR_NOERROR Then
  167.       m_Error = sCode
  168.       Exit Function
  169.    End If
  170.    dwLenM = (mciStatusParms.dwReturn) And &HFF
  171.    dwLenS = (mciStatusParms.dwReturn \ 256) And &HFF
  172.    dwLenF = ((mciStatusParms.dwReturn \ 65536) And &HFF) + 1
  173.    dwPosM = m_Tracks(m_NTracks - 1).Minutes
  174.    dwPosS = m_Tracks(m_NTracks - 1).Seconds
  175.    dwPosF = m_Tracks(m_NTracks - 1).Frames
  176.    dwpos = (dwPosM * 60 * 75) + (dwPosS * 75) + dwPosF + _
  177.            (dwLenM * 60 * 75) + (dwLenS * 75) + dwLenF
  178.    m_Tracks(m_NTracks).Frames = dwpos Mod 75
  179.    dwpos = dwpos \ 75
  180.    m_Tracks(m_NTracks).Seconds = dwpos Mod 60
  181.    dwpos = dwpos \ 60
  182.    m_Tracks(m_NTracks).Minutes = dwpos
  183.    m_Length = ((m_Tracks(m_NTracks).Minutes * 60) + (m_Tracks(m_NTracks).Seconds)) - _
  184.               ((m_Tracks(0).Minutes * 60) + (m_Tracks(0).Seconds))
  185.    sum = 0
  186.    For p1 = 0 To m_NTracks - 1
  187.       p2 = m_Tracks(p1).Minutes * 60 + m_Tracks(p1).Seconds
  188.       Do While p2 > 0
  189.          sum = sum + (p2 Mod 10)
  190.          p2 = p2 \ 10
  191.       Loop
  192.    Next p1
  193.    m_CID = LCase$(LeftZeroPad(Hex$(sum Mod &HFF), 2) & LeftZeroPad(Hex$(m_Length), 4) & LeftZeroPad(Hex$(m_NTracks), 2))
  194.    LoadCDInfo = True
  195. End Function
  196.  
  197. Public Function QueryString() As String
  198.     Dim p1 As Integer, s As String
  199.     On Error GoTo CHK
  200.     s = "cddb query " & m_CID & "+" & m_NTracks
  201.     For p1 = 0 To m_NTracks - 1
  202.         s = s & "+" & Format$(m_Tracks(p1).FrameOffset)
  203.     Next
  204.     QueryString = s & "+" & Format$(m_Tracks(m_NTracks).Minutes * 60) + (m_Tracks(m_NTracks).Seconds)
  205. CHK:
  206.     Select Case Err.Number
  207.     Case 0
  208.     Case 9
  209.         MsgBox "Drive not ready. Try again."
  210.         Exit Function
  211.     Case Else
  212.         MsgBox Err.Number & " " & Err.Description
  213.         Exit Function
  214.     End Select
  215. End Function
  216.  
  217. Private Function LeftZeroPad(s As String, n As Integer) As String
  218.    If Len(s) < n Then
  219.       LeftZeroPad = String$(n - Len(s), "0") & s
  220.    Else
  221.       LeftZeroPad = s
  222.    End If
  223. End Function
  224.